home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / STUTTGART / LANG / SCHEME / GNU / SCM4E1 / !Scm / slib / strcase < prev    next >
Text File  |  1993-09-21  |  1KB  |  43 lines
  1. ;;;; strcase.scm String casing functions.
  2. ; Copyright (C) Feb 1992 Dirk Lutzebaeck (lutzeb@cs.tu-berlin.de)
  3. ; Modified by Aubrey Jaffer Nov 1992.
  4. ; Authors of the original version were Ken Dickey and Aubrey Jaffer.
  5.  
  6. ;string-upcase, string-downcase, string-capitalize
  7. ; are obvious string conversion procedures and are non destructive.
  8. ;string-upcase!, string-downcase!, string-capitalize!
  9. ; are destructive versions.
  10.  
  11. (define (string-upcase! str)
  12.   (do ((i (- (string-length str) 1) (- i 1)))
  13.       ((< i 0) str)
  14.     (string-set! str i (char-upcase (string-ref str i)))))
  15.  
  16. (define (string-upcase str)
  17.   (string-upcase! (string-copy str)))
  18.   
  19. (define (string-downcase! str)
  20.   (do ((i (- (string-length str) 1) (- i 1)))
  21.       ((< i 0) str)
  22.     (string-set! str i (char-downcase (string-ref str i)))))
  23.  
  24. (define (string-downcase str)
  25.   (string-downcase! (string-copy str)))
  26.  
  27. (define (string-capitalize! str)    ; "hello" -> "Hello"
  28.   (let ((non-first-alpha #f)        ; "hELLO" -> "Hello"
  29.     (str-len (string-length str)))    ; "*hello" -> "*Hello"
  30.     (do ((i 0 (+ i 1)))            ; "hello you" -> "Hello You"
  31.     ((= i str-len) str)
  32.       (let ((c (string-ref str i)))
  33.     (if (char-alphabetic? c)
  34.         (if non-first-alpha
  35.         (string-set! str i (char-downcase c))
  36.         (begin
  37.           (set! non-first-alpha #t)
  38.           (string-set! str i (char-upcase c))))
  39.         (set! non-first-alpha #f))))))
  40.  
  41. (define (string-capitalize str)
  42.   (string-capitalize! (string-copy str)))
  43.